LOGIC Apps

home *** CD-ROM | disk | FTP | other *** search

/ LOGIC Apps / Logic-APPLE_II_APPS.iso / pc / LOGIC Apple II 5.25" Library - Forth / FORTH5.dsk < prev next >

Wrap

Text File | 2012-02-16 | 143KB | 1 lines

CONVERT DROP ; : PROMPT SP@ 249 > IF ELSE ( LEAVES COORDINATES ON STACK ) 2DUP SWAP CV CH ( IF THEY WERE GIVEN ) HOME 2INPUT 2SWAP 2DROP ; ( CLEAR STACK ) ( FROM JERRY LEVAN - FORTH DIMENSIONS II/1 PAGE 6 ) LATEST PFA CFA , ; IMMEDIATE ( INPUT AND 2INPUT WILL RETURN SINGLE AND DOUBLE PRECISION ) ELSE ( NO ACTION TO TAKE ) CR DROP DUP CH 7 EMIT ." RANGE ERROR" MYSELF THEN ; ( PARAMETERS ARE PASSED, THE PROMPT WILL BE AT THE CURRENT ) ( CURSOR LOCATION AND THE RESULT WILL BE ON THE STACK WITH ) ( NOTHING BENEATH IT. I.E. THE STACK REMAINS UNCHANGED ) ( EXCEPT FOR THE RETURNED RESULT ON TOP. ) : TEST ( CHECK THE SINGLE NUMBER INPUT ROUTINE ) ( ---- N1 ) HOME INPUT ( NUMBERS RESPECTIVELY. THEY PROMPT WITH A QUESTION MARK. ) ( IF VERTICAL AND HORIZONTAL PARAMETERS ARE PASSED VIA THE ) ( STACK, THE PROMPT WILL BE AT THAT LOCATION AND THE PARA- ) ( METERS WILL REMAIN ON THE STACK UNDER THE RESULT. IF NO ) ( NUMBER INPUT ROUTINES PAGE 3 ) : 2INPUT ( INPUT DBL PREC INTEGER ) PROMPT (INPUT) ; ( NUMBER INPUT ROUTINES PAGE 2 ) : (INPUT) ( GET A DOUBLE-PREC INTEGER --- D1 ) PAD 9 EXPECT 0 0 PAD 1- ROT ROT 2DROP ; ( CLEAR STACK ) : 2TEST ( CHECK THE DOUBLE NUMBER INPUT ROUTINE ) ( ---- D1 ) ( NUMBER INPUT ROUTINES PAGE 1 ) FORTH DEFINITIONS DECIMAL : MYSELF ( COMPILES THE WORD CURRENTLY BEING DEFINED INTO ) ( ITSELF, THUS ENABLING RECURSION. ) THEN ." ?" ; ( IN NO COORDS THEN NO MOVE ) : INPUT ( GET A SINGLE-PREC INTEGER --- N1 ) PROMPT -868 CALL (INPUT) 0= IF ( LOAD SCREEN PUBLIC DOMAIN FORTH STUFF JULY 7 82 JLA GDG ) ( THESE PROGRAMS ARE ALL WRITTEN USING MICROMOTION FORTH79 ) ( PROGRAMS PROVIDED TO IAC BY: ) ( SOURCE APPLE USERS GROUP -- SOURCE ID TCA265 ) ( 38 LIST ) ( STACK DISPLAY INSTRUCTIONS ) ( 20 LOAD ) ( CORRECTED DISK FORMTTER ) ( 1 3 THRU ) ( MYSELF, SGL & DBL NUMBER SCREEN INPUT ) ( 31 37 THRU ) ( IDIOT-PROOF KEYBOARD INPUT ) ( 2525 BEVERLEY AVE #9 ) ( SANTA MONICA, CA 90405 ) ( PROGRAMS BY GEORGE GIRTON ) ( 69 75 THRU ) ( FORTH DECOMPILER ) ( 80 94 THRU ) ( COMMUNITREE MICROMODEM UTILITIES ) ( REQUIRES MICRO-MOTION STRING UTILITIES ) ( 40 46 THRU ) ( GAME OF LIFE ) ( 50 51 THRU ) ( ROD'S COLOR PATTERN ) ( 60 63 THRU ) ( CLASSIC QUEENS PROBLEM ) ( 10 12 THRU ) ( BUBBLE SORT ) ( 13 19 THRU ) ( SQUEAK, ALARUM, BLUES ) ( 25 LOAD ) ( DVORAK KEYBOARD ) ( 26 LOAD ) ( BASEPREFIX $, Q, % ) ( LOAD SCREEN CONTINUED ) ( PROGRAMS BY JOEL AMROMIN ) ( 30 LOAD ) ( STACK DISPLAY ) ( 27 29 THRU ) ( TRANSIENT DEFINITIONS ) ( CONT ON NEXT SCREEN ) ( AND 'PRINTOUT' TO PRINT THE SORTED LIST) 35 100 STRING-ARRAY SONGS ( HOLDS TARGET WORDS FOR SORT ) 25 STRING TP ( TEMPORARY STRING FOR SWITCH ) : SWITCH JAY @ SONGS TP S! JAY @ 1- SONGS JAY @ SONGS S! TP JAY @ 1- SONGS S! ; ." PRESSING 'RETURN' AFTER EACH ONE." CR CR ." IF YOU HAVE NO MORE WORDS TO ENTER" CR ." THEN ENTER 'ZZZ'." CR CR CR CR BEGIN 1 ZZ +! ( BUBBLE SORT JANUARY 10 1982 GDG) ( INPUT, OUTPUT, AND INTERNAL SWITCH ) : TARGETS 0 ZZ ! HOME ." ENTER THE WORDS TO BE SORTED," CR ( BUBBLE SORT JANUARY 10 1982 GDG) ( STRING AND VARIABLE DECLARATIONS ) ( 10 12 THRU ) ( TYPE THE WORD 'TARGETS' FOR INPUT, 'SORT' TO SORT,) ." ENTER A WORD OR 'ZZZ'" CR INPUT$ ZZ @ SONGS S! CR ZZ @ SONGS " ZZZ" S= UNTIL ; VARIABLE EX ( EXCHANGE FLAG -- HAS EXCHANGE OCCURRED? ) VARIABLE ZZ ( TOTAL NUMBER OF WORDS ) VARIABLE JAY ( COUNTER FOR BUBBLE ) ( BUBBLE SORT JANUARY 10 1982 GDG) ( BUBBLE SORT PASS, MAIN PROGRAM STRUCTURE ) : BUBBLE ( ONE BUBBLE FROM BOTTOM TO TOP) BEGIN -1 JAY +! CODE REST 1 L: PHA, PLA, 2 L: N 2 + INC, ( LENGTH) 4 L: N 2 + INC, 5 L# BNE, N 3 + INC, 6 L# BNE, NEXT JMP, 5 L: NOP, N 8 + STA, 6 L: DEY, 8 L# BEQ, N 8 + STA, 7 L: 4 L# BNE, CF C, CF C, C3 C, C3 C, B8 C, B8 C, AE C, AE C, A4 C, A4 C, 9B C, 9B C, 92 C, 92 C, 8A C, 8A C, 82 C, 82 C, 7B C, 7B C, 74 C, 74 C, 6D C, 6E C, 67 C, 68 C, 61 C, 62 C, 5C C, 5C C, 57 C, 57 C, 3 L: NOP, N 8 + STA, ( NOT A REST) 4 L: 1 L# BNE, ( ALWAYS TAKEN) END-CODE JAY @ SONGS JAY @ 1- SONGS S< IF SWITCH 1 EX ! ( SET SWITCH FLAG ) THEN 20 C, 21 C, 1E C, 1F C, 1D C, 1D C, 1B C, 1C C, 1A C, 1A C, 18 C, 19 C, 17 C, 17 C, 15 C, 16 C, 14 C, 15 C, 13 C, 14 C, 12 C, 12 C, 11 C, 11 C, 10 C, 10 C, 0F C, 10 C, 0E C, 0F C, DECIMAL 1 L: .A LSR, ( SHIFT) 2 L# BEQ, N 6 + LSR, ( DT) 1 L# BNE, 2 L: NOTES ,Y LDA, SEC, N 6 + SBC, N 7 + STA, INY, NOTES ,Y LDA, 52 C, 52 C, 4D C, 4E C, 49 C, 49 C, 45 C, 45 C, 41 C, 41 C, 3D C, 3E C, 3A C, 3A C, 36 C, 37 C, 33 C, 34 C, 30 C, 31 C, 2E C, 2E C, 2B C, 2C C, 29 C, 29 C, 26 C, 27 C, 24 C, 25 C, 22 C, 23 C, ( SQUEAK FEBRUARY 12 1982 GDG) CODE (SQUEAK) 1 # LDA, SETUP JSR, N LDA, .A ASL, TAY, NOTES ,Y LDA, N 6 + STA, ' VOICE LDA, JAY @ 1 = UNTIL ; : SORT BEGIN 0 EX ! ( RESET THE EXCHANGE FLAG ) ( SQUEAK FEBRUARY 12 1982 GDG) VARIABLE VOICE 32 VOICE ! ( MAY BE 2, 8, 16, 32, OR 64) ( 32 GIVES BEST PITCH FOR ALL VALUES) N 6 + ADC, N 6 + STA, 0 # LDA, SEC, N 1+ SBC, ( DUR) N 3 + STA, ( LEN + 1 ) 0 # LDA, N 2 + STA, N 7 + LDA, 3 L# BNE, ' REST JMP, 3 L: N 7 + LDY, SPEAKER LDA, ( SQUEAK FEBRUARY 12 1982 GDG) HEX C030 CONSTANT SPEAKER CREATE NOTES 0 C, 0 C, F6 C, F6 C, E8 C, E8 C, DB C, DB C, 3 L# BNE, N 3 + INC, ( LENGTH 1+) 4 L# BNE, NEXT JMP, ZZ @ JAY ! ( FROM THE TOP AGAIN ) BUBBLE ( SETS EX IF EXCHANGE HAS OCCURRED ) EX @ NOT UNTIL ; ( IF NO EXCHANGE, SORT IS COMPLETE ) : PRINTOUT ZZ @ 1 DO I SONGS TYPE CR LOOP ; ( SQUEAK FEBRUARY 12 1982 GDG) 8 L: N 6 + LDY, SPEAKER LDA, 9 L: N 2 + INC, 10 L# BNE, N 3 + INC, 11 L# BNE, NEXT JMP, 10 L: NOP, N 8 + STA, 42 C, 12 C, 43 C, 12 C, 39 C, 24 C, 48 C, 12 C, 46 C, 12 C, 43 C, 12 C, 39 C, 12 C, 43 C, 12 C, 46 C, 12 C, 48 C, 12 C, 46 C, 60 C, 42 C, 12 C, 43 C, 12 C, 39 C, 24 C, 48 C, 24 C, 46 C, 24 C, 69 0 DO I 2* (BLUES) + @ (SQUEAK) LOOP 0 255 SQUEAK 39 15 SQUEAK ; : TEST 30 1 DO I RANGE ! BLUES LOOP ; 15 IVAR DUR CREATE T 28 C, 27 C, 28 C, 30 C, 28 C, 30 C, 32 C, 30 C, 39 C, 12 C, 36 C, 12 C, 39 C, 24 C, 39 C, 24 C, 48 C, 12 C, 46 C, 12 C, 48 C, 12 C, 46 C, 36 C, 45 C, 24 C, 44 C, 12 C, 42 C, 12 C, 44 C, 12 C, 42 C, 12 C, 48 C, 24 C, 46 C, 24 C, 11 L: DEY, 3 L# BEQ, N 8 + STA, 12 L: 9 L# BNE, NEXT JMP, END-CODE : PAUSE 5000 0 DO LOOP ; : PH BEGIN ALARUM PAUSE ?KEY UNTIL ; VARIABLE RANGE : BLUES ( REGULAR VERSION) 69 0 DO I 2* (BLUES) + @ DUP 255 AND RANGE @ - SWAP >< 255 AND 28 C, 27 C, 27 C, 27 C, 28 C, 28 C, : ALARUM 12 0 DO I T + C@ DUR @ SQUEAK LOOP 28 DUR @ 2* SQUEAK ; ( BLUES FEBRUARY 12 1982 GDG) 42 C, 12 C, 43 C, 12 C, 39 C, 24 C, 49 C, 12 C, 48 C, 12 C, 46 C, 12 C, 43 C, 12 C, 41 C, 12 C, 39 C, 12 C, 36 C, 12 C, 34 C, 36 C, 36 C, 24 C, : SQUEAK ( PITCH, DURATION -- ) >< OR (SQUEAK) ; : TEST 50 1 DO I 100 SQUEAK LOOP ; ( BLUES FEBRUARY 12 1982 GDG) CREATE (BLUES) 42 C, 12 C, 43 C, 12 C, 39 C, 24 C, 48 C, 12 C, 46 C, 36 C, 42 C, 12 C, 43 C, 12 C, 39 C, 24 C, 49 C, 24 C, 48 C, 24 C, 3 2 */ SQUEAK LOOP 39 RANGE @ - 255 SQUEAK ; : BLUES.A ( FAST VERSION) ( IVAR, ALARUM, PH FEBRUARY 12 1982 GDG) ( IVAR IS THE SAME AS 'VARIABLE' IN FIG-FORTH) : IVAR CREATE , DOES> ; 42 C, 12 C, 43 C, 12 C, 44 C, 12 C, 45 C, 12 C, 46 C, 12 C, 48 C, 12 C, 46 C, 24 C, 42 C, 12 C, 43 C, 12 C, 39 C, 24 C, 36 C, 12 C, 39 C, 12 C, 41 C, 12 C, 39 C, 12 C, 42 C, 12 C, 43 C, 12 C, ( FORMAT DATA DISK ) HEX : DRIVE ( N --- ) ( SELECT DRIVE N ) [ IBLOCK 1+ ] LITERAL @ [ IBLOCK 0F + ] LITERAL ! 1- DUP #DRS U< NOT 6 ?ERROR 2* SL:DR + @ [ IBLOCK 1+ ] LITERAL ! ; : CLEAN ( DRIVE# --- ) ( FORMAT DISK & WRITE BLANK SCREENS ) DUP DRIVE 1- 3E8 * CR ." *FORMATTING*" 0 0 0 4 RWTS 8 ?ERROR EMPTY-BUFFERS B/DR 0 DO DUP I + BUFFER 400 BL FILL UPDATE LOOP DROP SAVE-BUFFERS EMPTY-BUFFERS ; DECIMAL BL WORD 0 0 ROT CONVERT 2DROP STATE @ IF [COMPILE] LITERAL THEN R> BASE ! ; 16 BASEPREFIX $ ( HEX) 2823 , 2229 , 2B3B , 2425 , 3D2A , 2F57 , 5A56 , 2D36 , 3537 , 3133 , 3039 , 3432 , 5338 , 3D3C , 3F3E , 4140 , 4A58 , 2E45 , 4955 , 4344 , 5448 , 4D4E , 5242 , 3A4C , 4F50 , 4759 , 2C4B , 4651 , AIRPORTS ORD AIRPORTS LAX - . XSAVE LDX, RTS, END-CODE : DVORAK ' (DVO) IOVEC ! ; : MMM DVORAK ; : AAA ' (KEY) IOVEC ! ; 5B27 , 5D5C , 5F5E , 6160 , 6362 , 6564 , 6766 , 6968 , 6B6A , 6D6C , 6F6E , 7170 , 7372 , 7574 , 7776 , 7978 , 7B7A , 7D7C , 7F7E , CODE (DVO) ' (KEY) JSR, TAX, DXLATE ,X LDA, FIRST 1000 - CONSTANT TAREA VARIABLE TP TAREA TP ! : TRANSIENT HERE TP @ DP ! ; : PERMANENT HERE TP ! DP ! ; ( BINARY, HEX, OCTAL MASK PREFIXES GDG) : BASEPREFIX CREATE C, IMMEDIATE DOES> BASE @ >R C@ BASE ! FORTH DEFINITIONS HEX VARIABLE DXLATE -2 ALLOT 0100 , 0302 , 0504 , 0706 , 0908 , 0B0A , 0D0C , 0F0E , 1110 , 1312 , 1514 , 1716 , 1918 , 1B1A , 1D1C , 1F1E , 2120 , 8 BASEPREFIX Q ( OCTAL) 2 BASEPREFIX % ( BINARY) 36 BASEPREFIX AIRPORTS ( AIRPORTS) ( TRANSIENT DEFINITIONS) : DISPOSE ( --- ) TAREA TP ! V-LINK : S0 SP@ DEPTH 1- 2* + ; ( --- BOTTOM OF STACK ) : S? CLR SP@ S0 OVER OVER - IF DO I 2 - @ 0 <# #S #> AP @ SWAP DUP 1+ AP +! CMOVE AP @ 7F0 > IF CLR THEN 5F CONSTANT UL 0D CONSTANT RETN 15 CONSTANT CTRL-U VARIABLE ROW VARIABLE COLUMN VARIABLE CHANGE 27 STRING PAD$ 27 STRING WORK$ : EQUATE ( N -- ) CREATE , IMMEDIATE DOES> @ STATE @ IF [COMPILE] LITERAL THEN ; : INSTALL ' SS CFA ' QUIT 10 + ! CR CR 750 28 20 FILL 7D0 28 20 FILL 14 25 C! 16 23 C! ; : REMOVE OLDCFA ' QUIT 10 + ! 18 23 C! ; DECIMAL BEGIN DUP BEGIN @ DUP TAREA U< UNTIL DUP ROT ! DUP 0= UNTIL DROP V-LINK @ BEGIN DUP 4 - ( NULL PAD$ BY "NULL$ PAD$ S!". THE MAXIMUM LENGTH OF ) ( THE INPUT STRING SHOULD BE ON THE TOP OF THE STACK. ) ( ON EXIT, THE RESULTING STRING WILL BE IN PAD$, WITH ) ( PAD$ REMAINING UNCHANGED IF THE USER ENTERED A NULL ) 7 EQUATE SOME-LONG-WORD-NAME PERMANENT : DEMO SOME-LONG-WORD-NAME . ; ( SCREEN I/O SCREEN 1 C. 1982 BY JOEL L. AMROMIN ) ( WRITTEN USING MICROMOTION FORTH 79 VERSION 2.0 ) ( REQUIRES STRING UTILITIES ON FORTH GRANDFATHER DISK ) ( THE USER MUST PLACE A DEFAULT STRING IN PAD$, OR ) BEGIN DUP BEGIN PFA LFA @ DUP TAREA U< UNTIL DUP ROT PFA LFA ! DUP 0= UNTIL DROP @ DUP 0= ( STACK AND STATUS TRACE - GUY T. GROTKE ) FORTH DEFINITIONS HEX VARIABLE AP ( ADDRESS POINTER ) : CLR 7D0 DUP AP ! 27 20 FILL ; ' QUIT 10 + @ CONSTANT OLDCFA ( STRING. ) FORTH DEFINITIONS HEX : TASK ; 25 CONSTANT VERT 24 CONSTANT HORIZ 8 CONSTANT CTRL-H ( TRANSIENT DEFINITIONS TESTS) TRANSIENT -2 +LOOP ELSE 2DROP THEN BASE @ DUP DECIMAL BD42 AP @ ! 0 <# #S #> AP @ 2+ SWAP CMOVE BASE ! ; : SS S? [ OLDCFA , ] ; UNTIL DROP [COMPILE] FORTH DEFINITIONS ; ( SCREEN I/O SCREEN 2 ) CODE KEYIN ( REPLACES MONITOR KEYIN ROUTINE ) N STY, HORIZ LDY, 28 )Y LDA, PHA, : BACKSPACE ( 8 --- ) ( HANDLE BACKSPACE ) WORK$ LEN DUP 0= IF BELL DROP ELSE 3 PICK SWAP - 1 = ELSE DUP EMIT DUP ADDCHAR ( OK, SO ADD IT TO STRING ) THEN THEN ENDCASE ; : UNDERLINE ( N --- ) ( PRINT N UNDERLINES, RETURN TO XY ) 0 DO UL EMIT LOOP RELOC ; : INITSTRING ( N --- ) ( SET UP XY & INIT STRING VARIABLES ) : RIGHT-ARROW ( 21 --- ) ( HANDLE RIGHT-ARROWS ) CHANGE C@ NOT IF PAD$ LEN WORK$ LEN > IF PAD$ WORK$ LEN 1+ 1 MID$ 2DUP TYPE WORK$ S+ THEN ELSE BELL THEN ; 3F # AND, 40 # ORA, 28 )Y STA, PLA, 1 L: C000 LDA, 1 L# BPL, C010 STA, PHA, 88 # CMP, 2 L# BNE, ' WORK$ 1+ LDA, 2 L# BEQ, ' WORK$ 1+ DEC, WORK$ + C! WORK$ 1+ SWAP 1- C! ; CTRL-U OF RIGHT-ARROW ENDOF RETN OF EXIT ENDOF DUP DUP 32 < SWAP 126 > OR ( CHECK CHARACTER VALIDITY ) IF BELL VERT C@ HORIZ C@ COLUMN C! ROW C! ( STORE XY COORDINATES ) DUP UNDERLINE PAD$ TYPE RELOC NULL$ WORK$ S! 0 CHANGE ! ; : ADDCHAR ( --- ) ( ADD CHARACTER WORK$ ) ( SCREEN I/O SCREEN 5 ) : CHARGET ( ---- ) ( GET & HANDLE A SINGLE CHARACTER ) KEYIN DUP CASE CTRL-H OF BACKSPACE ENDOF DF # LDA, 28 )Y STA, DEY, 28 )Y STA, HORIZ DEC, 2 L: PLA, SEC, 80 # SBC, PHA, ( SCREEN I/O SCREEN 4 ) : STARTCHANGE ( N --- ) ( START CHANGE OF STRING ) RELOC UNDERLINE WORK$ TYPE 1 CHANGE C! ; ELSE CHANGE C@ NOT ( HAS NO CHANGE BEEN MADE YET? ) IF 3 PICK STARTCHANGE THEN WORK$ LEN 4 PICK = IF BELL ( ALREADY AT END OF MAX LENGTH ) ( SCREEN I/O SCREEN 3 ) : RELOC ( CURSOR TO START OF INPUT ) ROW C@ CV COLUMN C@ CH ; IF 2 SPACES 8 DUP EMIT EMIT ELSE CHANGE C@ NOT IF OVER STARTCHANGE THEN THEN THEN ; N LDA, PUSH JMP, END-CODE DECIMAL ( SCREEN I/O SCREEN 6 ) : $ERROR ( --- ) CR BELL ." STRING LENGTH ERROR .." CR ; ( STACK POINTER, AND BASE WILL BE ) ( SHOWN AT THE BOTTOM OF THE SCREEN ) ( WHENEVER FORTH RETURNS TO COMMAND ) ( LEVEL. ) IF CV ELSE $ERROR ABORT THEN DUP C/SL < OVER -1 > AND IF CH ( THE ROUTINE IS DIRECTLY LINKED INTO ) ( THE 'QUIT' ROUTINE. ) : GETSTR ( N --- ) ( GET A STRING OF LENGTH N AND STORE IT IN PAD$ ) DUP COLUMN C@ + C/SL 1- > ( DON'T GO OFF SCREEN ) 15 HOME 10 CV ." TEST >" GETSTR ; : TEST. PAD$ TYPE ; ( --- ) ( PRINTS PAD$ ) ELSE $ERROR ABORT THEN TYPE ; : STEST ( --- ) ( GETS A STRING OF LENGTH 15 ) IF $ERROR ABORT THEN INITSTRING BEGIN CHARGET RETN = UNTIL ( GET CHARS UNTIL RETURN ) RELOC SPACES ( CLEAR OUT THE UNDERLINES ) ( STACK AND TRACE INSTRUCTIONS ) ( LOAD SCREEN #30 THEN TYPE 'INSTALL' ) ( THE CURRENT STACK VALUES, ) ( STRING TEST ) : STR. ( $VARIABLE V H --- ) ( PRINT STRING AT V H ) SWAP DUP 24 < OVER -1 > AND ( IMPORTANT !!! DO NOT FORGET AP ) ( UNTIL YOU TYPE 'REMOVE' OR YOU WILL ) ( CRASH YOUR FORTH. THAT IS BECAUSE ) CHANGE C@ IF WORK$ PAD$ S! THEN ( SET PAD$ TO FINAL VALUE ) RELOC PAD$ 2DUP TYPE ( TYPE PAD$ AT XY ) -TRAILING PAD$ S! ; ( CLEAR EXCESS BLANKS FROM PAD$ ) ( LIFE BY JOEL AMROMIN ) : LIFETASK ; FORTH DEFINITIONS DECIMAL 30 CONSTANT COLUMNS 20 CONSTANT ROWS ( DEFINE DIMENSIONS ) IF DROP 0 THEN SWAP CHECK-CELL ; : UP ( MOVE UP ONE ROW ) DROP ; THIS-WORLD CALC ( GET ADDRESS OF CELL ) C@ R> + ( ADD CELL TO COUNT ) ROT ROT ; ( RESTORE STACK ) : SET-CELL ( SET CELL IN NEXT GEN ) ( R C ADDR --- R C ADDR ) DUP OFFSET + 1 SWAP C! ; COLUMNS ROWS * CONSTANT SIZE VARIABLE THIS-WORLD SIZE 2 - ALLOT ( MAIN ARRAY ) VARIABLE NEXT-WORLD SIZE 2 - ALLOT ( WORKING ARRAY ) NEXT-WORLD THIS-WORLD - CONSTANT OFFSET ( DIFFERENCE BETWEEN ) : FWD ( MOVE FWD 1 COLUMN ) 1+ DUP COLUMNS = IF DROP 0 THEN CHECK-CELL ; IF ( A CELL IS ALIVE HERE ) CASE 2 OF SET-CELL ENDOF 3 OF SET-CELL ENDOF : BACK ( MOVE BACK 1 COLUMN ) 1- DUP 0< IF COLUMNS + THEN CHECK-CELL ; ( LIFE PAGE 4 ) : EVALUATE ( R C # --- R C ) >R THIS-WORLD CALC DUP C@ R> SWAP ( ARRAYS ) : CLEAR ( CLEAR AN ARRAY WORLD --- ) DUP SIZE + SWAP DO 0 I C! ( LIFE PAGE 3 ) : DOWN ( MOVE DOWN ONE ROW ) SWAP 1+ DUP ROWS = ENDCASE ELSE 3 = IF SET-CELL THEN THEN ( LIFE PAGE 2 ) : CHECK-CELL ( # R C --- # R C ) ROT >R SWAP 1- DUP 0< IF ROWS + THEN SWAP CHECK-CELL ; LOOP ; : CALC ( CALUCULATE ADDR IN ARRAY R C BASE --- R C ADDRESS ) >R 2DUP SWAP COLUMNS * + R> + ; ( LIFE PAGE 5 ) : SCAN-NEIGHBORS ( R C --- R C ) 2DUP 0 ROT ROT ( R C 0 R C ) : CLEAR-POINT ( V H --- ) ( CLEAR A CELL ) THIS-WORLD CALC 0 SWAP C! DISPLAY ; HOME DISPLAY -1 .COUNT 0 DO NEXT-WORLD CLEAR 20 CH ." ROW" 30 CH ." COL" ROWS 0 DO I 22 CV 25 CH DUP . COLUMNS 0 DO : NEW-WORLD ( --- ) ( CLEAR OUT ALL CELLS ) THIS-WORLD CLEAR DISPLAY ; BACK DOWN FWD FWD UP UP BACK BACK DROP DROP EVALUATE ; : DISPLAY ( SHOW THIS WORLD ) NEXT-WORLD THIS-WORLD SIZE CMOVE DISPLAY I .COUNT ?KEY IF LEAVE THEN LOOP ; I 22 CV 35 CH DUP . SCAN-NEIGHBORS DROP LOOP DROP LOOP 0 CV 0 CH ROWS 0 DO COLUMNS 0 DO J I THIS-WORLD CALC C@ IF ." *" ELSE SPACE THEN ( LIFE PAGE 7 ) : SET-POINT ( V H --- ) ( SET A CELL ) THIS-WORLD CALC 1 SWAP C! 2DROP DISPLAY ; ( LIFE PAGE 6 ) : .COUNT 22 CV 0 CH 1+ ." GENERATION" 4 .R ; ( SHOW COUNT ) : LIFE ( # OF GENS --- ) : RNDSET ( N --- ) ( RANDOMLY SET 1 CELL ) THIS-WORLD DUP SIZE + SWAP DO ( PER N CELLS ) RND OVER MOD 0= I C! LOOP DROP DISPLAY ; 2DROP LOOP CR LOOP ; : HUES DUP 3 4 PICK OVER + */ >R OVER 4 PICK 12 */ R> + COLOR ; : PAIR 2DUP PLOT 2DUP SWAP PLOT ; : FIXEM 40 SWAP - ; DROP DROP ; 20 0 DO I HUES OVER + DRAW LOOP ?KEY IF TX ABORT CALL THEN DROP LOOP DROP LOOP ; ( ROD'S COLOR PATTERN CONT ) : MAINLOOP LGR 51 3 DO I 20 1 DO I ( ROD'S COLOR PATTERN ) FORTH DECIMAL ( REQUIRES LORES ) : ROD BEGIN 1 MAINLOOP 0= UNTIL ; ;S : DRAW OVER PAIR FIXEM PAIR SWAP FIXEM PAIR SWAP DROP OVER PAIR ( QUEENS PROBLEM ) FORTH DEFINITIONS DECIMAL : MYSELF ( PROVIDES FOR RECURSION ) : PRINTSOL ( PRINT A SOLUTION ) 1 SOL +! SOL @ ." SOLUTION " 2 .R ." FOUND ON TRY " TRIES @ 6 .R CR CR : QUEENS ( ACTUALLY RUNS PROBLEM ) 0 TRIES ! 0 SOL ! 0 CR TRY 7 EMIT ; CR CR ." TYPE 'QUEENS' TO RUN PROGRAM..." CR ;S : SAFE BUILDUP @ >R + B @ >R DROP A @ R> R> * * ; : MARK LATEST PFA CFA , ; IMMEDIATE : IARRAY ( BUILDS ARRAY OF 1'S ) CREATE 0 DO 1 , LOOP SP! QUIT THEN DUP I SAFE IF DUP I MARK DUP I SWAP X ! DUP 7 < IF DUP 1+ ?STACK MYSELF ELSE BUILDUP 0 SWAP ! + B 0 SWAP ! DROP A 0 SWAP ! ; : UNMARK BUILDUP 1 SWAP ! + B 1 SWAP ! DROP A 1 SWAP ! ; ( QUEENS CONT. ) : TRY ( SEARCH FOR ANSWERS ) 8 0 DO 1 TRIES +! ?KEY IF DOES> SWAP 2* + ; ( LEAVE ADDRESS IN ARRAY ) 8 IARRAY A ( THESE FORM WORKSPACE ) ( QUEENS CONT. ) PRINTSOL THEN DUP I UNMARK THEN LOOP DROP ; ( QUEENS CON'T ) : BUILDUP SWAP OVER OVER OVER OVER - 7 + C ; 8 0 DO I X @ 1+ 4 .R LOOP CR CR ; 16 IARRAY B ( FOR THE SOLUTIONS ) 16 IARRAY C 8 IARRAY X ( TRIAL SOLUTIONS ) VARIABLE TRIES VARIABLE SOL -FIND (LIT) ADF CONSTANT LIT.ADR -FIND : ADF @ CONSTANT DOCOL.ADR -FIND 0BRANCH ADF CONSTANT 0BRANCH.ADR -FIND BRANCH ADF CONSTANT BRANCH.ADR 3 - -1 TRAVERSE DUP 1+ DUP C@ 59 = IF 1 QUIT.FLAG ! THEN SWAP C@ 31 AND TYPE ; : -FIND FIND DUP IF 2+ DUP NFA C@ 3F AND 1 THEN ; VARIABLE BASTOR -FIND (;CODE) ADF CONSTANT PSCODE.ADR -FIND COMPILE ADF CONSTANT COMP.ADR VARIABLE COMP.FLAG VARIABLE WORD.PTR VARIABLE QUIT.FLAG : D. 0 D.R ; DECIMAL CR CR : N. SWAP DUP DECIMAL . HEX 0 ROT CH ." ( $" D. ." )" DECIMAL ; : PDOTQ.DSP ( TXT STRING ) 65152 CALL WORD.PTR @ 2+ DUP >R DUP C@ + 1- : SET10 BASE @ BASTOR ! DECIMAL ; : FIXBASE BASTOR @ BASE ! ; ( DECOMPILER CONT ) 0 DUP DUP QUIT.FLAG ! WORD.PTR ! COMP.FLAG ! ( DECOMPILER CONT ) : ADF DROP DROP 2 - ; -FIND (LOOP) ADF CONSTANT LOOP.ADR WORD.PTR ! R> DUP DUP C@ + 1+ SWAP 1+ DO I C@ EMIT LOOP 65156 CALL ; : WORD.DSP ( DISPLAY NAME FROM CFA ) ( FORTH DECOMPILER ) ." COMPILING FORTH DECOMPILER..." CR FORTH DEFINITIONS HEX -FIND (+LOOP) ADF CONSTANT PLOOP.ADR -FIND (.") ADF CONSTANT PDOTQ.ADR -FIND C/L ADF @ CONSTANT CONST.ADR -FIND (VAR) ADF @ CONSTANT VAR.ADR ( DECOMPILER CONT ) : BRANCH.DSP ." TO " WORD.PTR @ 2+ DUP WORD.PTR BRANCH.ADR OF ." BRANCH " BRANCH.DSP CR ENDOF LIT.ADR OF WORD.PTR @ 2+ DUP WORD.PTR ! @ 14 N. CR ENDOF LOOP.ADR OF ." (LOOP) " BRANCH.DSP CR ENDOF COMP.ADR OF COMP.ADR WORD.DSP CR 1 COMP.FLAG +! ENDOF : DIS SET10 -FIND 0= IF PSCODE.ADR OF WORD.PTR @ @ WORD.DSP CR 1 QUIT.FLAG ! ENDOF DUP WORD.DSP CR ENDCASE WORD.PTR @ 2+ WORD.PTR ! QUIT.FLAG @ UNTIL CR THEN THEN FIXBASE ; ! DUP @ COMP.FLAG @ 2 = IF ." (" WORD.DSP ." )" DROP ELSE + 0 HEX D. THEN 0 COMP.FLAG ! DECIMAL ; BEGIN WORD.PTR @ DUP 0 HEX D. SPACE DECIMAL @ COMP.FLAG @ 1 = IF 1 COMP.FLAG +! ELSE 0 COMP.FLAG ! THEN ." TO DECOMPILE WORD 'XX' TYPE: DIS XX" CR CR CR ;S 3 SPACES ." ? NOT IN GLOSSARY" CR ELSE DROP DUP DUP 2 - @ = IF CR ." <PRIMITIVE> " CR DROP ELSE 0 QUIT.FLAG ! 2- WORD.PTR ! CR CR ( DECOMPILER CONT ) HOME ." COMPILATION COMPLETE..." CR CR : VAR.DSP ( DISPLAY A VARIABLE ) ." VARIABLE, VALUE: " WORD.PTR @ 2+ @ 28 N. 1 QUIT.FLAG ! ; : CONST.DSP ( DISPLAY A CONSTANT ) ( DECOMPILER CONT ) CASE DOCOL.ADR OF ." : " CR ENDOF 0BRANCH.ADR OF ." BRANCH IF FALSE " BRANCH.DSP CR ENDOF ( DECOMPILER CONT ) PLOOP.ADR OF ." (+LOOP) " BRANCH.DSP CR ENDOF PDOTQ.ADR OF ." PRINT: " PDOTQ.DSP CR ENDOF CONST.ADR OF CONST.DSP ENDOF VAR.ADR OF VAR.DSP ENDOF ." CONSTANT, VALUE: " WORD.PTR @ 2+ @ 28 N. 1 QUIT.FLAG ! ; ( MODEM UTILITIES -- BY THE COMMUNITREE GROUP ) ( THE DOCUMENTATION FOR THIS PUBLIC DOMAIN SOFTWARE CAN BE ) ( FOUND IN THE MAY 1982 EDITION OF DR. DOBB'S JOURNAL ) 24000 ( ADDRESS TO START THE DATA AREA ) 2 RAMBYTES MODEMSLOT ( SLOT # ) 2 RAMBYTES XSPEED ( 300 OR 110 ) VARIABLE PARITYTABLE 0E ALLOT : T ( 16# ---- , MOVE NIBBLE PARITIES IN ) 10 0 DO PARITYTABLE I + C! LOOP ; 2 RAMBYTES COUNT2 ( FOR TIMEOUT ) 2 RAMBYTES CALL# ( COUNT FOR LOG ) ( APPLE SPECIFIC OPERATIONS ) : MODEMTASK ; HEX ( : ?KEY ?TERMINAL ) ( INCLUDE THIS DEFINITION ON VERSIONS ) DECIMAL 2 RAMBYTES NOLOGONF ( T= LOGONS DISABLED ) 2 RAMBYTES HALFDUPLEXF ( T= HALF ) ( DATA AREAS ) 0 1 1 0 1 0 0 1 1 0 0 1 0 1 1 0 T FORGET T ( MODEM CONT. FLAGS ) 2 RAMBYTES LOCALF ( TRUE= LOCAL OP ) 2 RAMBYTES ABORTF ( T= KILL COMMAND ) ( OF FORTH 79 PRIOR TO 2.0 ) : KEYLOOK ( --- CHAR-OR-0 ) ?KEY ( MODEM CONT. VARIABLES ) : RAMBYTES ( ADDR N --- ADDR. ALLOCATE ) OVER CONSTANT + ; 81 RAMBYTES AREA$ ( INPUT BUFFER ) CR ." NEXT AVAILABLE ADDRESS:" . CR ( MODEM CONT. MISC DATA STRUCTURES ) ( PARITY TABLE OF 16 0-OR-1 VALUES ) HEX 2 RAMBYTES TEMP ( INPUT CHARACTER ) 2 RAMBYTES PARITY ( ODD OR EVEN ) 2 RAMBYTES CHARINDEX ( INPUT LN INDEX ) 2 RAMBYTES COUNT1 ( FOR TIMEOUT ) IF C000 C@ 7F AND ELSE 0 THEN ; DECIMAL ( MODEM CONT. REGISTERS INITIALIZATION ) HEX : MMRING ( --- ADDR. MODEM RING & CNTRL ) DUMMY ; ( THIS WILL SAY COMPUTER IS NEEDED ) : ?ESCAPE ( --- BOOL. T= ABORT THE CMD ) KEYLOOK DUP 1B = OVER 5A = OR IF ( ESC OR Z KEY PRESSED ) ?KEY DROP ( CLEAR STROBE ) X?HUNGUP IF DROP 100 THEN ; DECIMAL IF 0 ( NOT 'HUNG UP' IF LOCAL ) ELSE 0 ( FLAG ) MMSTATUS C@ 4 AND ( CARRIER LOSS? ) ELSE DROP 0 ( NEEDN'T ABORT ) THEN ; DECIMAL C085 MODEMSLOT @ 10 * + ; : MMSTATUS ( --- ADDR. MODEM STATUS ) MMRING 1+ ; : MMDATA ( --- ADDR. MODEM DATA ) THEN ; DECIMAL PARITYTABLE + C@ + 1 = IF 80 THEN ; : SETPARITY ( ---. TEST FIRST CR ) TEMP C@ 80 AND 80 XOR PARITY ! ; IF XINIT MMSTATUS C@ 4 AND ( STILL NO CARRIER ) IF DROP 1 ( HUNG UP ) THEN THEN ( MODEM CONT. MODEM PARITY; CHARACTER LOOK ) HEX : EVENPARITY ( N --- N. SET EVEN PARITY ) DUP 000F AND PARITYTABLE + C@ OVER 00F0 AND 10 / MMRING 2+ ; : XINIT ( ---. INITIALIZE ) 3 MMSTATUS C! ( MUST DO THIS FIRST ) XSPEED @ IF 8B 15 ( 300, NO PARITY ON STOP ) ( MODEM CONT. SESSION ESCAPE ) HEX : DUMMY ; : ESCMSG ( ---. DUMMY - PATCHED LATER ) : XKEYLOOK ( --- N;0;256 XKEY NO WAIT ) MMSTATUS C@ 1 AND IF MMDATA C@ 7F AND ELSE 0 THEN ( MODEM CONT. DETECT USER HANG-UP ) HEX : X?HUNGUP ( --- BOOL. 1= HANG UP ) LOCALF @ 07 EMIT 1 NOLOGONF ! CR ." LOGONS DISABLED" CR 1B = IF ." USER WARNED - 5 MINUTES" CR ESCMSG 1 ( ABORT ) ELSE 0 ( NEEDN'T ABORT ) THEN ELSE 8A 11 ( 110, TWO STOPS ) THEN MMSTATUS C! MMRING C! ; ( SET SPEED ) DECIMAL ( MODEM CONT. MODEM WRITE; HANGUP PHONE; WAIT RING ) HEX : XEMIT ( N ---. ) BEGIN MMSTATUS C@ 2 AND UNTIL MMDATA C! ; 1 COUNT1 +! COUNT1 @ 80 = IF 0 COUNT1 ! 1 COUNT2 +! COUNT2 @ 384 = ( SECONDS - HEX ) IF DROP 100 XHANGUP 1 ABORTF ! UNTIL ; DECIMAL OVER 127 AND ( STRIP PARITY ) DUP 8 = ( BACKSPACE ) OVER 13 = OR ( CARRIAGE RETURN ) SWAP 127 = OR ( ALSO BACKSPACE ) DECIMAL : XEMITP ( N ---. HANDLE PARITY ) EVENPARITY PARITY @ XOR ( ODD? ) XEMIT ; BEGIN MMSTATUS C@ 1 AND IF DROP MMDATA C@ ECHO DUP TEMP C! 7F AND ELSE OR ( HALFDUPLEX ) CHARINDEX @ AREA$ 79 + = OR ( AT COLUMN 80 ) 0= IF DUP XEMIT THEN ; ( MODEM CONT. READ A CHARCTER FROM THE MODEM ) HEX : XKEY ( --- N. 256= HUNG UP ) 0 COUNT1 ! 0 COUNT2 ! 0 ( INITIAL VALUE ) : XHANGUP ( ---. HANG UP PHONE ) 9 MMRING C! ; : XWAITRING ( ---. WAIT FOR CALL ) ( MODEM CONT. TIMEOUT IF USER DOES NOTHING ) HEX : TIMEOUT? ( FLAG --- FLAG. TEST IF IDLE ) X?HUNGUP IF DROP 100 THEN ?ESCAPE IF DROP 0D THEN THEN TIMEOUT? DUP ( MODEM CONT. ECHO, MISC ) : ECHO ( N --- N. ECHO TO REMOTE ) ( DON'T ECHO IF: ) HALFDUPLEXF @ THEN THEN ; BEGIN ( WAIT FOR RING ) XHANGUP MMRING C@ 80 AND 0= UNTIL ; ( PHONE RINGS ) DECIMAL ( MODEM CONT. GETCALL - FIRST PART ) HEX : GETSTRING ( --- ) XHANGUP 3 MMSTATUS C! 15 MMSTATUS C! NOLOGONF @ IF CR ." ERROR, NO CARD IN MODEM SLOT " MODEMSLOT ? CR ." RESTART PROGRAM" 7 EMIT BEGIN 0 UNTIL 0 LOCALF ! ( SET REMOTE MODE ) BEGIN ( RECEIVING CALLS ) GETSTRING ?KEY DROP ( CLEAR STROBE ) 0 XSPEED ! ( TOGGLE SPEED UNTIL GET CARRIAGE RETURN ) 0 E00 0 DO ( 60 SECOND TIMEOUT ) CR ." SYSTEM IS CLEAR" 07 EMIT ?KEY DROP ( CLEAR STROBE ) KEY DROP ( PAUSE FOR OPERATOR ) 0 NOLOGONF ! THEN 1 CALL# +! ( INCREMENT CALL # ) 0D XEMITP ( RETURN THE CARRIAGE RETURN FOUND ) ." CONNECTED" ; DECIMAL XSPEED 1 TOGGLE XINIT XKEY 0D = XCR IF DROP 1 SETPARITY LEAVE THEN LOOP ( TILL FIND CR OR TIME OUT ) UNTIL ( NOT TIMED OUT ) CR ." #" CALL# @ 3 .R ." WAITING FOR CALL.." XWAITRING ." RING" CR 6 SPACES ; DECIMAL ( MODEM CONT. MAKE SURE SLOT NOT EMPTY ) HEX : SLOTTEST ( ---. ABORT IF NO CARD ) C000 MODEMSLOT @ 100 * + DUP @ SWAP @ - IF ( MODEM CONT. GETCALL - RECEIVE A VALID CALL ) HEX : GETCALL THEN ; DECIMAL : XCR ( TYPE CHARACTER ON LOG ) MMSTATUS C@ 4 AND 0= IF TEMP C@ . THEN ;